home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / prog.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  5.7 KB  |  299 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.  
  24.     prog.c
  25. */
  26.  
  27. #include "include.h"
  28.  
  29. /*
  30.     use of VS in tagbody:
  31.  
  32.          old_top ->    |  id    |
  33.             | lex0    |
  34.             | lex1    |
  35.             | lex2    |
  36.        tinf_base ->    | tag1    |    where 'bodyi' is the part of tag-body
  37.             | body1    |    that follows the tag 'tagi'.
  38.             |   :    |
  39.                 :        i.e.
  40.             |   :    |    tag-body
  41.             | tagn    |    = (...tag1..........tagn.............)
  42.             | bodyn    |          |        |<- bodyn ->|
  43.          new_top ->    |    |          |                |
  44.                VS              |<-------- body1 -------->|
  45. */
  46.  
  47. Ftagbody(body)
  48. object body;
  49. {
  50.     object *old_top = vs_top;
  51.     object *new_top;
  52.     object *tinf;
  53.     object *tinf_base;
  54.     object *env = lex_env;
  55.     object id = alloc_frame_id();
  56.     object bodysv = body;
  57.     object label;
  58.     enum type item_type;
  59.  
  60.     vs_push(id);
  61.     lex_copy();
  62.     tinf_base = vs_top;
  63.     while (!endp(body)) {
  64.         label = MMcar(body);
  65.         item_type = type_of(label);
  66.         if (item_type == t_symbol || item_type == t_fixnum ||
  67.                 item_type == t_bignum) {
  68.             lex_tag_bind(label, id);
  69.             vs_push(label);
  70.             vs_push(MMcdr(body));
  71.         }
  72.         body = MMcdr(body);
  73.     }
  74.  
  75.     new_top = vs_top;
  76.  
  77.     frs_push(FRS_CATCH, id);
  78.     body = bodysv;
  79.     if (nlj_active) {
  80.         label = cdr(nlj_tag);
  81.         nlj_active = FALSE;
  82.         for(tinf = tinf_base;
  83.             tinf < new_top && !eql(tinf[0],label);
  84.             tinf += 2)
  85.             ;
  86.         if (tinf >= new_top)
  87.             FEerror("Someone tried to RETURN-FROM a TAGBODY.",0);
  88.         body = tinf[1];
  89.     }
  90.     while (body != Cnil) {
  91.         vs_top = new_top;
  92.         item_type = type_of(MMcar(body));
  93.         if (item_type != t_symbol && item_type != t_fixnum &&
  94.             item_type != t_bignum)
  95.             eval(MMcar(body));
  96.         body = MMcdr(body);
  97.     }
  98.     frs_pop();
  99.     lex_env = env;
  100.     vs_base = old_top;
  101.     vs_top = old_top+1;
  102.     vs_base[0] = Cnil;
  103. }
  104.  
  105. Fprog(arg)
  106. object arg;
  107. {
  108.     object *oldlex = lex_env;
  109.     struct bind_temp *start;
  110.     object body;
  111.     bds_ptr old_bds_top = bds_top;
  112.  
  113.     if (endp(arg))
  114.         FEtoo_few_argumentsF(arg);
  115.  
  116.     make_nil_block();
  117.  
  118.     if (nlj_active) {
  119.         nlj_active = FALSE;
  120.         goto END;
  121.     }
  122.  
  123.     start = (struct bind_temp *)vs_top;
  124.     let_var_list(arg->c.c_car);
  125.     body = let_bind(arg->c.c_cdr, start, (struct bind_temp *)vs_top);
  126.     vs_top = (object *)start;
  127.     vs_push(body);
  128.  
  129.     Ftagbody(body);
  130.  
  131. END:
  132.     bds_unwind(old_bds_top);
  133.     frs_pop();
  134.     lex_env = oldlex;
  135. }
  136.  
  137. FprogA(arg)
  138. object arg;
  139. {
  140.     object *oldlex = lex_env;
  141.     object *top;
  142.     struct bind_temp *start;
  143.     object body;
  144.     bds_ptr old_bds_top = bds_top;
  145.  
  146.     if (endp(arg))
  147.         FEtoo_few_argumentsF(arg);
  148.  
  149.     make_nil_block();
  150.  
  151.     if (nlj_active) {
  152.         nlj_active = FALSE;
  153.         goto END;
  154.     }
  155.  
  156.     start = (struct bind_temp *) vs_top;
  157.     let_var_list(arg->c.c_car);
  158.     body = letA_bind(arg->c.c_cdr, start, (struct bind_temp *)vs_top);
  159.     vs_top = (object *)start;
  160.     vs_push(body);
  161.  
  162.     Ftagbody(body);
  163.  
  164. END:
  165.     bds_unwind(old_bds_top);
  166.     frs_pop();
  167.     lex_env = oldlex;
  168. }
  169.  
  170. Fgo(args)
  171. object args;
  172. {
  173.     object lex_tag;
  174.     frame_ptr fr;
  175.     if (endp(args))
  176.         FEtoo_few_argumentsF(args);
  177.     if (!endp(MMcdr(args)))
  178.         FEtoo_many_argumentsF(args);
  179.     lex_tag = lex_tag_sch(MMcar(args));
  180.     if (MMnull(lex_tag))
  181.         FEerror("~S is an undefined tag.", 1, MMcar(args));
  182.     fr = frs_sch(MMcaddr(lex_tag));
  183.     if (fr == NULL)
  184.         FEerror("The tag ~S is missing.", 1, MMcar(args));
  185.     vs_push(MMcons(MMcaddr(lex_tag), MMcar(lex_tag)));
  186.     vs_base = vs_top;
  187.     unwind(fr,vs_top[-1]);
  188.     /*  never reached  */
  189. }
  190.  
  191. Fprogv(args)
  192. object args;
  193. {
  194.     object *top;
  195.     object symbols;
  196.     object values;
  197.     bds_ptr old_bds_top;
  198.     object var;
  199.  
  200.     if (endp(args) || endp(MMcdr(args)))
  201.          FEtoo_few_argumentsF(args);
  202.  
  203.     old_bds_top=bds_top;
  204.  
  205.     top=vs_top;
  206.     eval(MMcar(args));
  207.     vs_top=top;
  208.     symbols=vs_base[0];
  209.     vs_push(symbols);
  210.     eval(MMcadr(args));
  211.     vs_top=top+1;
  212.     values=vs_base[0];
  213.     vs_push(values);
  214.     while (!endp(symbols)) {
  215.         var = MMcar(symbols);
  216.  
  217.         if (type_of(var)!=t_symbol) not_a_symbol(var);
  218.         if ((enum stype)var->s.s_stype == stp_constant)
  219.             FEerror("Cannot bind the constant ~S.", 1, var);
  220.  
  221.         if (endp(values)) {
  222.             bds_bind(var, OBJNULL);
  223.         } else {
  224.             bds_bind(var, MMcar(values));
  225.             values=MMcdr(values);
  226.         }
  227.         symbols=MMcdr(symbols);
  228.     }
  229.  
  230.     Fprogn(MMcddr(args));
  231.  
  232.     bds_unwind(old_bds_top);
  233. }
  234.  
  235. Fprogn(body)
  236. object body;
  237. {
  238.     if(endp(body)) {
  239.         vs_base=vs_top;
  240.         vs_push(Cnil);
  241.     } else {
  242.         object *top=vs_top;
  243.         do {
  244.             vs_top=top;
  245.             eval(MMcar(body));
  246.             body=MMcdr(body);
  247.         } while (!endp(body));
  248.     }
  249. }
  250.  
  251. Fprog1(arg)
  252. object arg;
  253. {
  254.     object *top = vs_top;
  255.  
  256.     if(endp(arg))
  257.         FEtoo_few_argumentsF(arg);
  258.     eval(MMcar(arg));
  259.     vs_top = top;
  260.     vs_push(vs_base[0]);
  261.     for(arg = MMcdr(arg);  !endp(arg);  vs_top = top+1, arg = MMcdr(arg))
  262.         eval(MMcar(arg));
  263.     vs_base = top;
  264.     vs_top = top + 1;
  265. }
  266.  
  267. Fprog2(arg)
  268. object arg;
  269. {
  270.     object *top = vs_top;
  271.  
  272.     if(endp(arg) || endp(MMcdr(arg)))
  273.         FEtoo_few_argumentsF(arg);
  274.     eval(MMcar(arg));
  275.     vs_top = top;
  276.     arg = MMcdr(arg);
  277.     eval(MMcar(arg));
  278.     vs_top = top;
  279.     vs_push(vs_base[0]);
  280.     for(arg = MMcdr(arg);  !endp(arg);  vs_top = top+1, arg = MMcdr(arg))
  281.         eval(MMcar(arg));
  282.     vs_base = top;
  283.     vs_top = top+1;
  284. }
  285.  
  286. init_prog()
  287. {
  288.     make_special_form("TAGBODY", Ftagbody);
  289.     make_special_form("PROG", Fprog);
  290.     make_special_form("PROG*", FprogA);
  291.     make_special_form("GO", Fgo);
  292.  
  293.     make_special_form("PROGV", Fprogv);
  294.  
  295.     make_special_form("PROGN",Fprogn);
  296.     make_special_form("PROG1",Fprog1);
  297.     make_special_form("PROG2",Fprog2);
  298. }
  299.